perm filename ACSHFT.F4[MSS,LCS] blob sn#086986 filedate 1974-03-19 generic text, type T, neo UTF8
00100		SUBROUTINE ACSHFT(RX)
00200		COMMON /XRN/RN(4000)
00300		COMMON /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA
00400		1,DBST,NFLG,IXX,ISEMI,IQT,F(50),IAMP,K,KN,M,MODE,IBLA
00500		DIMENSION R(8,100)
00600		EQUIVALENCE (R,RN(3001)),(A,F(1)),(B,F(2)),(X,F(4)),
00700		1(Y,F(5)),(Z,F(6)),(JD,F(7)),(RN1,F(8)),(RH,F(9))
00800		Z=0
00900		L=K-1
01000		M=L-ABS(RX)
01100		JD=1
01200		RN1=99
01300		Y=-.23
01400		IF(RX.LT.0)GO TO 1
01500		L=M
01600		M=K-1
01700		JD=-1
01800	1	DO 2 N=M,L,JD
01900	C  DOES IT HAVE AN ACCID?
02000		IF(AMOD(R(5,N),10.).EQ.0)GO TO 2
02100		A=R(6,N+1)
02200		B=R(6,N-1)
02300		IF(RN1.NE.99)GO TO 3
02400	C  IS THIS THE FIRST ACCID?
02500		RN1=R(4,N)
02600		GO TO 6
02700	3	RH=R(4,N)
02800		IF(ABS(RH-RN1).LT.5)GO TO 4
02900		RN1=RH
03000		IF(Y.GT.0)Z=Z+.04
03050	C STOPS OCT., ETC. ACCIS BEING MOVED TO LEFT.
03100		Y=-.23+Z
03200	6	IF(A.EQ.20.OR.B.EQ.20)Y=Z
03300	4	X=0
03400		IF(R(6,N).EQ.20)X=-.24
03500		IF(R(6,N).EQ.10)X=.24
03600		Y=Y+.23
03700		IF(X+Y.LT.1)GO TO 7
03800		RN1=RH
03900		Z=Z+.04
04000		Y=0
04100		IF(A.EQ.20.OR.B.EQ.20)Y=.23
04200	C  SO Y DOESN'T GET >1.
04300		Y=Y+Z
04400	7	X=X+Y
04450		IF(ABS(X-.04).LT..01)X=0
04500		IF(X.GE.0)GO TO 5
04600		Y=.23+Z
04700		X=Z
04800	5	R(5,N)=R(5,N)+X
04900	2	CONTINUE
05000		END
05100